home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Cabral IRC262939112001.psc / bold_beta.bas < prev    next >
Encoding:
BASIC Source File  |  2000-03-21  |  7.6 KB  |  200 lines
  1. Attribute VB_Name = "ColorRTF"
  2. Option Explicit
  3.  
  4.  
  5.  
  6. Public Sub DoColor(RTF As vbalRichEdit, strColor As String)
  7.     Dim i As Integer
  8.     Dim a As Integer
  9.     Dim b As Integer
  10.     Dim b1 As Integer
  11.     Dim b2 As Integer
  12.     Dim ColorCode As Integer
  13.     Dim BGColorCode As String
  14.     Dim ColorFound As Boolean
  15.     Dim BoldFound As Boolean
  16.     
  17.     Dim color(0 To 15) As Long
  18.     color(0) = vbWhite 'white
  19.     color(1) = vbBlack 'black
  20.     color(2) = RGB(0, 0, 140) 'dark blue
  21.     color(3) = RGB(0, 140, 0) 'dark green
  22.     color(4) = vbRed 'red
  23.     color(5) = RGB(110, 65, 0) 'brown
  24.     color(6) = RGB(140, 0, 140) 'purple
  25.     color(7) = RGB(248, 146, 0) 'orange
  26.     color(8) = RGB(255, 255, 0) 'yellow
  27.     color(9) = vbGreen 'light green
  28.     color(10) = RGB(0, 140, 140) 'dark blue green
  29.     color(11) = RGB(0, 255, 255) 'light blue green
  30.     color(12) = vbBlue 'light blue
  31.     color(13) = vbMagenta 'magenta
  32.     color(14) = RGB(140, 140, 140) 'grey
  33.     color(15) = RGB(200, 200, 200) 'light grey
  34.     
  35.     ColorFound = False
  36.     BoldFound = False
  37.     If InStr(strColor, "") < InStr(strColor, "") Then
  38.         a = InStr(strColor, "")
  39.         If a = 0 Then a = 1
  40.         'MsgBox "COLOR"
  41.     Else
  42.         a = InStr(strColor, "")
  43.         If a = 0 Then a = 1
  44.         'MsgBox "BOLD"
  45.     End If
  46.     Do Until InStr(strColor, "") = 0 And InStr(strColor, "") = 0
  47.     'msgBox strColor
  48.     'For i = 1 To Len(strColor)
  49.         'find the start of color code or bold code
  50.         RTF.InsertContents SF_TEXT, Mid(strColor, 1, a - 1)
  51.         b1 = InStr(strColor, "") 'color
  52.         b2 = InStr(strColor, "")  'bold
  53.         If b1 = 0 And b2 <> 0 Then
  54.             b1 = b2 + 1
  55.         Else
  56.             If b2 = 0 And b1 <> 0 Then
  57.                 b2 = b1 + 1
  58.             End If
  59.         End If
  60.         If b1 < b2 Then
  61.             a = b1
  62.             If a = 0 Then a = 1
  63.             'MsgBox "COLOR"
  64.         Else
  65.             a = b2
  66.             If a = 0 Then a = 1
  67.             'MsgBox "BOLD"
  68.         End If
  69.         If strColor = "" Then Exit Do
  70.         If Mid(strColor, a, 1) = "" Then
  71.             'if it's another color Kode then just delete it and move on
  72.             If Mid(strColor, a + 1, 1) = "" Then
  73.                 strColor = "" & Mid(strColor, a + 2)
  74.                 i = i - 1
  75.             End If
  76.             'get first number in color code
  77.             If IsNumeric(Mid(strColor, a + 1, 1)) Then
  78.                 ColorCode = Mid(strColor, a + 1, 1)
  79.                 ColorFound = True
  80.                 If IsNumeric(Mid(strColor, a + 2, 1)) Then
  81.                     ColorCode = ColorCode & Mid(strColor, a + 2, 1)
  82.                     strColor = Mid(strColor, a + 3)
  83.                     'loop until colorcode less than 15
  84.                     Do Until ColorCode < 16
  85.                         If ColorCode > 15 Then
  86.                             ColorCode = ColorCode - 15
  87.                         End If
  88.                     Loop
  89.                     Debug.Print "2: " & Mid(strColor, 1, 1)
  90.                     'START of background color if colorcode LEN = 2
  91.                     If Mid(strColor, 1, 1) = "," Then
  92.                         If IsNumeric(Mid(strColor, 2, 1)) Then
  93.                             'first color code # on bg color
  94.                             BGColorCode = BGColorCode & Mid(strColor, 2, 1)
  95.                             strColor = Mid(strColor, 3)
  96.                             If IsNumeric(Mid(strColor, 1, 1)) Then
  97.                                 BGColorCode = BGColorCode & Mid(strColor, 1, 1)
  98.                                 strColor = Mid(strColor, 2)
  99.                             Else
  100.                                 'BG Color code is only one number
  101.                             End If
  102.                         Else
  103.                             'there is no bg color
  104.                         End If
  105.                     End If
  106.                     'loop until BG colorcode less than 15
  107.                     If BGColorCode <> "" Then
  108.                         Do Until BGColorCode < 16
  109.                             If BGColorCode > 15 Then
  110.                                 BGColorCode = BGColorCode - 15
  111.                             End If
  112.                         Loop
  113.                     End If
  114.                     If BGColorCode <> "" Then
  115.                         RTF.FontBackColour = color(BGColorCode)
  116.                     End If
  117.                     'reset Back Ground Color
  118.                     BGColorCode = ""
  119.                     'END BG COLOR
  120.                     RTF.FontColour = color(ColorCode)
  121.                     ColorFound = False
  122.                 Else
  123.                     'if not a second digit
  124.                     RTF.FontColour = color(ColorCode)
  125.                     strColor = Mid(strColor, a + 2)
  126.                     Debug.Print "1: " & Mid(strColor, 1, 1)
  127.                     'start of background color if colorcode LEN = 1
  128.                     If Mid(strColor, 1, 1) = "," Then
  129.                         If IsNumeric(Mid(strColor, 2, 1)) Then
  130.                             'first color code # on bg color
  131.                             BGColorCode = BGColorCode & Mid(strColor, 2, 1)
  132.                             strColor = Mid(strColor, 3)
  133.                             If IsNumeric(Mid(strColor, 1, 1)) Then
  134.                                 BGColorCode = BGColorCode & Mid(strColor, 1, 1)
  135.                                 strColor = Mid(strColor, 2)
  136.                             Else
  137.                                 'BG Color code is only one number
  138.                             End If
  139.                         Else
  140.                             'there is no bg color
  141.                         End If
  142.                     End If
  143.                     'loop until BG colorcode less than 15
  144.                     If BGColorCode <> "" Then
  145.                         Do Until BGColorCode < 16
  146.                             If BGColorCode > 15 Then
  147.                                 BGColorCode = BGColorCode - 15
  148.                             End If
  149.                         Loop
  150.                     End If
  151.                     If BGColorCode <> "" Then
  152.                         RTF.FontBackColour = color(BGColorCode)
  153.                     End If
  154.                     'reset Back Ground Color
  155.                     BGColorCode = ""
  156.                 End If
  157.             Else
  158.                 'No Color code after initial color code
  159.                 RTF.FontColour = color(1)
  160.                 strColor = Mid(strColor, a + 1)
  161.             End If
  162.         Else
  163.             If Mid(strColor, a, 1) = "" Then
  164.                 RTF.FontBold = BoldFound
  165.                 strColor = Mid(strColor, a + 1)
  166.                 BoldFound = Not (BoldFound)
  167.                 'MsgBox BoldFound
  168.                 b1 = InStr(strColor, "") 'color
  169.                 b2 = InStr(strColor, "")  'bold
  170.                 If b1 = 0 And b2 <> 0 Then
  171.                     b1 = b2 + 1
  172.                 Else
  173.                     If b2 = 0 And b1 <> 0 Then
  174.                         b2 = b1 + 1
  175.                     End If
  176.                 End If
  177.                 If b1 <> 0 Or b2 <> 0 Then
  178.                     If b1 < b2 Then
  179.                         RTF.InsertContents SF_TEXT, Mid(strColor, 1, b1 - 1)
  180.                     Else
  181.                         RTF.InsertContents SF_TEXT, Mid(strColor, 1, b2 - 1)
  182.                     End If
  183.                 Else
  184.                     RTF.InsertContents SF_TEXT, Mid(strColor, 1)
  185.                 End If
  186.             End If
  187.             'strColor = Mid(strColor, a + 1)
  188.             'i = 0
  189.             'DoEvents
  190.         End If
  191.     'Next i
  192.     Loop
  193.     RTF.InsertContents SF_TEXT, strColor
  194.     RTF.FontBold = False
  195.     RTF.FontColour = vbBlack
  196.     RTF.InsertContents SF_TEXT, vbCrLf
  197.  
  198. End Sub
  199.  
  200.